perm filename PXTOGF.PSC[MF,ALS] blob
sn#785074 filedate 1985-03-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00028 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 program PXtoGF( PXLfile, GFfile )
C00005 00003 const
C00008 00004 type
C00010 00005 var
C00012 00006 { simple arithmetics: }
C00013 00007 { special reset/rewrite }
C00015 00008 { read 1,2,4 bytes }
C00020 00009 { write 1,2,4 bytes }
C00024 00010 procedure Initbittable
C00026 00011 procedure Init
C00028 00012 function Word
C00030 00013 procedure LocPXLdirectory
C00033 00014 procedure GetPXLendinfo
C00037 00015 procedure Swap
C00040 00016 procedure Sortfont
C00041 00017 procedure LocPXLrasters
C00042 00018 procedure PutGFpreamble
C00044 00019 function Charexists
C00046 00020 procedure PutGFboc
C00050 00021 function Getpaint(var Length:integer): boolean
C00054 00022 procedure Paint(D: integer)
C00055 00023 procedure Down(D: integer)
C00056 00024 procedure PutGFpaint
C00059 00025 procedure PutGFpost
C00061 00026 procedure PutGFlocator
C00063 00027 procedure PutGFppost
C00065 00028 { main } begin
C00068 ENDMK
C⊗;
program PXtoGF( PXLfile, GFfile );
{-----------------------------------------------------------------
This will eventualy read .pxl files and write out
an equivalent .gf file.
-----------------------------------------------------------------}
const
PXLID = 1001; {input as a long word}
GFID = 131; {output is a single byte}
SIG = 223; {GF files finish with 4 or more of these}
ASCIIMAX = 127; {128 characters maximum in PXL files}
PXLENDBYTES = 2068; {512 + 5 longwords, fixed at end of PXL files}
PPI = 72.27; {points per inch, as in TeX}
STRINGMAX = 32; {length of character strings, a 1 byte quantity}
PXLBUFSIZE = 99; {bytes allowed per a row in pxl file minus one (=3 mod 4)}
COMMENTSTRING = 'This file was created by PXtoGF.';
HEADERSTRING = 'This is PXtoGF, Version 0.99. ';
BLACK = true;
WHITE = false;
ALLWHITE = 0; {encodings of solid color bytes in PXL files}
ALLBLACK = 255;
TWO16 = 65536; {for scaling scaled integers, especially hppp/vppp}
FIX = 1048576; {Knuth's scaling scheme}
PRE = 247; {These are all GF opcodes}
BOC = 67;
BOC1 = 68;
EOC = 69;
POST = 248;
POSTPOST = 249;
CHARLOC = 245;
CHARLOC0 = 246;
PAINT0 = 0;
PAINT1 = 1;
PAINTONE = 64;
PAINTTWO = 65;
PAINTTHR = 66;
SKIP0 = 70;
SKIPONE = 71;
SKIPTWO = 72;
SKIPTHR = 73;
NEWROW0 = 74;
XXX1 = 239;
MaxNewrow = 164; {Last new row opcode is NEWROW0 + MaxNewrow}
MaxPaint = 63; {Last no parameter paint command is
PAINT0 + MaxPaint}
type
byte = 0..255;
longword = array[1..4] of byte;
bitpos = 0..8;
bytestobits = array[byte] of bitpos;
bitstobytes = array[bitpos] of byte;
string = packed array[1..STRINGMAX] of char;
fontfile = packed file of byte;
charrec = record
code: 0..ASCIIMAX;
pixelwidth,
pixelheight,
xoffset,
yoffset,
PXLrasterptr,
GFbocptr,
tfmwidth {a real fraction * FIX}
:integer;
end;
fontarray = array[0..ASCIIMAX] of charrec;
{corresponds roughly to PXL's font directory}
pxlbufarray = array[0..pxlbufsize] of byte;
var
GFcomment: string;
PXLfile,GFfile: fontfile;
FileOK: boolean;
I: integer;
Font: fontarray;
GFBYTES, {bytes "put" to date, also an index to byte about to be put}
specials, {number of bytes of specials before next BOC}
Postptr, {index of the POST byte in the GF file}
Postminm, {font-wide extremes: }
Postmaxm,
Postminn,
Postmaxn,
Sum, {PXL's checksum exactly}
Mag, {PXL's magnification exactly}
Dsize {PXL's design size exactly}
: integer;
FirstBlack: bytestobits; {constant arrays initialized by Init}
BlackLeftof: bitstobytes;
PXLbuf: pxlbufarray; {holds current row from pxl file}
PXLbyte, PXLbuflimit: integer; {current and final byte number in PXLbuf}
PXLbufend: integer; {total number of bytes read into PXLbuf}
PXLbit: integer; {bit position in current byte}
PXLcolor: boolean; {color that we are ready to paint at PXLbit}
{ simple arithmetics: }
function Max(M,N:integer):integer;
begin
if M > N then Max := M else Max := N;
end;
function Min(M,N:integer):integer;
begin
if M < N then Min := M else Min := N;
end;
function Ceiling(N,D:integer):integer;
begin
Ceiling := (N+D-1) div D;
end;
{ special reset/rewrite }
procedure Resetfontfile
{----------------------------------------------------------------}
( var xFile: fontfile;
var Fileexists: boolean );
{-----------------------------------------------------------------
All special switching done here, also check for existence
-----------------------------------------------------------------}
begin
reset(xFile,'','/o/b:8');
Fileexists := not eof(xFile);
if not Fileexists then writeln(tty,'ERROR: reset non-existent file.');
end;
procedure Rewritefontfile
{----------------------------------------------------------------}
( var xFile: fontfile );
{-----------------------------------------------------------------
All special switching done here, also check for existence.
-----------------------------------------------------------------}
var ch: char;
begin
reset(xFile,'','/o');
if not eof(xFile) then begin
write(tty,'WARNING: GFfile already exists. Type <cr> to continue.');
read(tty,ch);
end;
rewrite(xFile,'','/b:8');
end;
{ read 1,2,4 bytes }
function Read1byte
{----------------------------------------------------------------}
( var xFile: fontfile ): integer;
{-----------------------------------------------------------------
Gets an 8 bit number out of a file of bytes.
Obviously advances xFile↑ by 1 bytes.
-----------------------------------------------------------------}
var A: byte;
begin
A := xFile↑; get(xFile);
Read1byte := A;
end;
{ Here is a more efficient way to read a row of pixels, one byte at a time. }
procedure ReadPXLbuf;
var i: integer;
begin
for i := 0 to PXLbufend
do begin
PXLbuf[i]:=PXLfile↑;
get(PXLfile);
end;
PXLbyte := 0;
PXLbit := 0;
PXLcolor := WHITE;
end;
function Read2bytes
{----------------------------------------------------------------}
( var xFile: fontfile ): integer;
{-----------------------------------------------------------------
Gets a 16 bit number out of a file of bytes.
Obviously advances xFile↑ by 2 bytes.
-----------------------------------------------------------------}
var A,B: byte;
begin
A := Read1Byte( xFile );
B := Read1Byte( xFile );
Read2bytes := A * 256 + B;
end;
function ReadSigned2bytes
{----------------------------------------------------------------}
( var xFile: fontfile ): integer;
{-----------------------------------------------------------------
Gets a 16 bit number out of a file of bytes.
Obviously advances xFile↑ by 2 bytes.
-----------------------------------------------------------------}
var A,B: byte;
begin
A := Read1Byte( xFile );
B := Read1Byte( xFile );
if A < 128 then begin
ReadSigned2bytes := A * 256 + B;
end else begin
ReadSigned2bytes := (A-256)*256 + B;
end;
end;
function Read4bytes
{----------------------------------------------------------------}
( var xFile: fontfile ): integer;
{-----------------------------------------------------------------
Gets a 32 bit number out of a file of bytes.
Obviously advances xFile↑ by 4 bytes.
-----------------------------------------------------------------}
var A,B,C,D: byte;
begin
A := Read1Byte( xFile );
B := Read1Byte( xFile );
C := Read1Byte( xFile );
D := Read1Byte( xFile );
if A < 128 then begin
Read4Bytes := ((A*256+B)*256+C)*256+D;
end else begin
Read4Bytes := (((A-256)*256+B)*256+C)*256+D;
end;
end;
{ write 1,2,4 bytes }
procedure Write1byte
{----------------------------------------------------------------}
( var xFile: fontfile;
I: integer );
{-----------------------------------------------------------------
0 <= I <= 2↑8 - 1
-----------------------------------------------------------------}
begin
{*** if (I < 0) or (I > 255) then begin
{*** writeln(tty,'ERROR: write1byte: ',I:0);
{*** end else begin }
xFile↑ := I;
put(xFile);
GFBYTES := GFBYTES + 1;
{*** end;}
end;
procedure Write2bytes
{----------------------------------------------------------------}
( var xFile: fontfile;
I: integer );
{-----------------------------------------------------------------
0 <= I <= 2↑16 - 1
-----------------------------------------------------------------}
begin
{***} if (I<0) or (I>65535) then begin
{***} writeln(tty,'ERROR: write2bytes: ',I:0);
{***} end else begin
Write1Byte( xFile, I div 256 );
Write1Byte( xFile, I mod 256 );
{***} end;
end;
procedure Write3bytes
{----------------------------------------------------------------}
( var xFile: fontfile;
I: integer );
{-----------------------------------------------------------------
0 <= I <= 2↑24 - 1
-----------------------------------------------------------------}
var B1,B2,B3: byte;
begin
{***} if (I<0) or (I>16777216) then begin
{***} writeln(tty,'ERROR: write2bytes: ',I:0);
{***} end else begin
Write1Byte( xFile, I div 65536 );
I := I mod 65536;
Write1Byte( xFile, I div 256 );
Write1Byte( xFile, I mod 256 );
{***} end;
end;
procedure Write4bytes
{----------------------------------------------------------------}
( var xFile: fontfile;
I: integer );
{-----------------------------------------------------------------
Outputs four bytes in two's complement notation,
without risking arithmetic overflow.
-----------------------------------------------------------------}
var B1,B2,B3,B4: byte;
begin
if I >= 0 then begin
Write1Byte( xFile, I div 16777216 );
end else begin
I := I + 1073741824; I := I + 1073741824;
Write1Byte( xFile, (I div 16777216) + 128 );
end;
I := I mod 16777216; Write1Byte( xFile, I div 65536 );
I := I mod 65536; Write1Byte( xFile, I div 256 );
Write1Byte( xFile, I mod 256 );
end;
procedure Initbittable
{----------------------------------------------------------------}
( var xTable: bytestobits );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var I: integer;
begin
xTable[0] := 8;
xTable[1] := 7;
for I := 2 to 3 do xTable[i] := 6;
for I := 4 to 7 do xTable[i] := 5;
for I := 8 to 15 do xTable[i] := 4;
for I := 16 to 31 do xTable[i] := 3;
for I := 32 to 63 do xTable[i] := 2;
for I := 64 to 127 do xTable[i] := 1;
for I := 128 to 255 do xTable[i] := 0;
end;
procedure Init
{----------------------------------------------------------------}
( var GFcomment: string;
var Postminm,Postmaxm,Postminn,Postmaxn: integer );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
begin
GFbytes := 0;
specials := 0;
GFcomment := COMMENTSTRING;
Postminm := MAXINT;
Postminn := MAXINT;
Postmaxm := -MAXINT;
Postmaxn := -MAXINT;
Initbittable( FirstBlack );
BlackLeftof[0] := 0;
BlackLeftof[1] := 128;
BlackLeftof[2] := 128+64;
BlackLeftof[3] := 128+64+32;
BlackLeftof[4] := 128+64+32+16;
BlackLeftof[5] := 128+64+32+16+8;
BlackLeftof[6] := 128+64+32+16+8+4;
BlackLeftof[7] := 128+64+32+16+8+4+2;
BlackLeftof[8] := 128+64+32+16+8+4+2+1;
end;
function Word
{----------------------------------------------------------------}
( xWord: longword;
Ptr: integer ): integer;
{-----------------------------------------------------------------
At input, Ptr is the low-order byte but it is
immediately moved to the high-order byte.
-----------------------------------------------------------------}
var Tmp,I: integer;
begin
Tmp := 0;
if Ptr = 4 then Ptr := 1 else Ptr := Ptr + 1;
for I := 1 to 4 do begin
Tmp := Tmp*256 + xWord[ Ptr ];
if Ptr = 4 then Ptr := 1 else Ptr := Ptr + 1;
end;
Word := Tmp;
end;
procedure LocPXLdirectory
{----------------------------------------------------------------}
( var PXLfile: fontfile;
var FileOK: boolean );
{-----------------------------------------------------------------
File verification includes these tests:
The file exists,
First and last long word = PXLID,
File contains at least PXLENDBYTES+4 bytes.
Location of directory consists of:
Open file,
Determine N, the number of bytes in the file,
Reopen and move to the (N-1 - PXLENDBYTES)th byte.
-----------------------------------------------------------------}
var Count, Ptr: integer;
Lastword: longword;
begin
Resetfontfile( PXLfile, FileOK );
if FileOK then begin
Count := 0; Ptr := 0;
while not eof(PXLfile) do begin
Count := Count + 1;
Ptr := Ptr + 1;
if Ptr > 4 then Ptr := 1;
Lastword[Ptr] := PXLfile↑;
get(PXLfile);
end;
if Count < (PXLENDBYTES + 4) then begin
FileOK := false;
writeln(tty,'ERROR: PXLfile is too short to be a PXL file.');
end else if Word( Lastword, Ptr ) <> PXLID then begin
FileOK := false;
writeln(tty,'ERROR: PXLfile does not end with PXLID.');
end else begin
Resetfontfile( PXLfile, FileOK );
if Read4bytes( PXLfile ) <> PXLID then begin
FileOK := false;
writeln(tty,'ERROR: PXLile does not begin with PXLID.');
end else begin
for Ptr := 1 to (Count - 4 - PXLENDBYTES) do get(PXLfile);
end;
end;
end;
end;
procedure GetPXLendinfo
{----------------------------------------------------------------}
( var PXLfile: fontfile;
var Font: fontarray;
var Sum, Mag, Dsize: integer );
{-----------------------------------------------------------------
Assumes PXLfile is valid and PXLfile↑ is the first
byte of the font directory.
-----------------------------------------------------------------}
var I: integer;
begin
for I := 0 to ASCIIMAX do with Font[I] do begin
code := I;
pixelwidth := Read2bytes( PXLfile );
pixelheight := Read2bytes( PXLfile );
xoffset := ReadSigned2bytes( PXLfile );
yoffset := ReadSigned2bytes( PXLfile );
PXLrasterptr := Read4bytes( PXLfile );
tfmwidth := Read4bytes( PXLfile ); {stays in FIX notation}
end;
Sum := Read4bytes( PXLfile );
Mag := Read4bytes( PXLfile );
Dsize := Read4bytes( PXLfile );
end;
procedure Swap
{----------------------------------------------------------------}
( var C1,C2: charrec );
{-----------------------------------------------------------------
C1 ↔ C2
-----------------------------------------------------------------}
var Tmp: charrec;
begin
Tmp := C1;
C1 := C2;
C2 := Tmp;
end;
procedure Sortfont
{----------------------------------------------------------------}
( var Font: fontarray );
{-----------------------------------------------------------------
Sorts charrec's in Font by .PXLrasterptr, thereby
putting them into the order they were created (lowest
rasterptr first).
-----------------------------------------------------------------}
var I,J: integer;
begin
for I := ASCIIMAX downto 1 do begin
for J := 1 to I do begin
if Font[ J-1 ].PXLrasterptr > Font[ J ].PXLrasterptr then begin
Swap( Font[J-1], Font[J] );
end;
end;
end;
end;
procedure LocPXLrasters
{----------------------------------------------------------------}
( var PXLfile: fontfile );
{-----------------------------------------------------------------
Reopens the file and ditches the first long word.
-----------------------------------------------------------------}
var B: boolean; {dummy}
begin
Resetfontfile( PXLfile, B );
get(PXLfile);
get(PXLfile);
get(PXLfile);
get(PXLfile);
end;
procedure PutGFpreamble
{----------------------------------------------------------------}
( var GFfile: fontfile;
GFcomment: string );
{-----------------------------------------------------------------
written to file => PRE,i[1],k[1],x[STRINGMAX]
-----------------------------------------------------------------}
var I: integer;
begin
Rewritefontfile( GFfile );
Write1byte( GFfile, PRE );
Write1byte( GFfile, GFID );
Write1byte( GFfile, STRINGMAX );
for I := 1 to STRINGMAX do Write1byte( GFfile, ord(GFcomment[I]) mod 256 );
end;
function Charexists
{----------------------------------------------------------------}
( Ch: charrec ): boolean;
{-----------------------------------------------------------------
Definition of PXL files states that all 4 long words
in the font directory will equal 0 if the character
does not exist. For the moment, if the raster pointer
equals zero, this function returns false and issues a
warning if other values are non-zero.
-----------------------------------------------------------------}
begin
with Ch do if PXLrasterptr <> 0 then begin
Charexists := true;
end else begin
Charexists := false;
if (pixelwidth <> 0) or
(pixelheight <> 0) or
(xoffset <> 0) or
(yoffset <> 0) or
(tfmwidth <> 0) then begin
writeln(tty,'WARNING: non-zero values for non-existent character');
end;
end;
end;
procedure PutGFboc
{----------------------------------------------------------------}
( var GFfile: fontfile;
var Ch: charrec;
var Postminm, Postmaxm,
Postminn, Postmaxn: integer );
{-----------------------------------------------------------------
One of the following options is written to file:
BOC c[4] p[4] minm[4] maxm[4] minn[4] maxn[4]
BOC1 c[1] delm[1] maxm[1] deln[1] maxn[4]
Also, assigns appropriate value to Ch.GFbocptr
and updates Post<extremes>.
-----------------------------------------------------------------}
var minm, maxm, minn, maxn, delm, deln: integer;
begin
with Ch do begin
minm := 0 - xoffset;
if minm < Postminm then Postminm := minm;
maxm := pixelwidth - xoffset;
if maxm > Postmaxm then Postmaxm := maxm;
minn := yoffset + 1 - pixelheight;
if minn < Postminn then Postminn := minn;
maxn := yoffset;
if maxn > Postmaxn then Postmaxn := maxn;
delm := maxm - minm;
deln := maxn - minn;
GFbocptr := GFBYTES-specials;
specials := 0;
If (0<=delm) and (delm<256) and (0<=maxm) and (maxm<256) and
(0<=deln) and (deln<256) and (0<=maxn) and (maxn<256)
then begin
Write1byte( GFfile, BOC1 );
Write1byte( GFfile, code );
Write1byte( GFfile, delm );
Write1byte( GFfile, maxm );
Write1byte( GFfile, deln );
Write1byte( GFfile, maxn );
end
else begin
Write1byte( GFfile, BOC );
Write4bytes( GFfile, code );
Write4bytes( GFfile, -1 ); {never any backpointers from PXL files}
Write4bytes( GFfile, minm );
Write4bytes( GFfile, maxm );
Write4bytes( GFfile, minn );
Write4bytes( GFfile, maxn );
end;
end;
end;
function Getpaint(var Length:integer): boolean;
{----------------------------------------------------------------
The PXLbuf array contains bytes 0, 1, .., PXLbuflimit, and each
byte contains bits 0, 1, .., 7 numbered from the left (most
significant position). We are about to paint bit PXLbit of
byte PXLbyte with color PXLcolor. All lower numbered bits
in the current byte also have this color. Find out how many
bit positions we can advance before we come to a pixel of a
different color, and set Length accordingly. The global variables
PXLbyte and PXLbit are updated accordingly, and the leading
bits of PXLbyte are changed to match the new PXLcolor. The
boolean value returned indicates whether or not we were
successful in finding a different colored pixel.
-----------------------------------------------------------------}
label 999; {exit label}
var Curbyte: integer; {a byte from PXLbuf}
Newbyte, Newbit: integer; {new values for PXLbyte and PXLbit}
begin
Newbyte := PXLbyte;
if PXLcolor=WHITE
then begin
while (Newbyte<PXLbuflimit) and (PXLbuf[Newbyte]=ALLWHITE)
do Newbyte := Newbyte + 1;
Curbyte := PXLbuf[Newbyte];
if Curbyte=ALLWHITE
then begin Getpaint:=false; goto 999; end;
end
else begin
while (Newbyte<PXLbuflimit) and (PXLbuf[Newbyte]=ALLBLACK)
do Newbyte := Newbyte + 1;
Curbyte := ALLBLACK - PXLbuf[Newbyte];
end;
Newbit := FirstBlack[Curbyte];
Length := 8*(Newbyte-PXLbyte) + (Newbit-PXLbit);
PXLbyte := Newbyte;
PXLbit := Newbit;
PXLcolor := not PXLcolor;
Curbyte := Curbyte + BlackLeftof[PXLbit];
if PXLcolor = BLACK then PXLbuf[PXLbyte] := Curbyte
else PXLbuf[PXLbyte] := ALLBLACK - Curbyte;
Getpaint := true;
999:end;
procedure Paint(D: integer);
begin
if D = 0 then begin
Write1byte( GFfile, PAINT0 );
end else if (D <= MaxPaint) then begin
Write1byte( GFfile, PAINT1 + D - 1 );
end else if (D <= 255) then begin
Write1byte( GFfile, PAINTONE );
Write1byte( GFfile, D );
end else if (D <= 65535) then begin
Write1byte( GFfile, PAINTTWO );
Write2bytes( GFfile, D );
end else if (D <= 16777215) then begin
Write1byte( GFfile, PAINTTHR );
Write3bytes( GFfile, D );
end else begin
write(tty,'ERROR: huge run-length, GFfile is invalid.');
end;
end;
procedure Down(D: integer);
begin
D := D-1;
if D >= 0 then
if D = 0 then begin
Write1byte( GFfile, SKIP0 );
end else if (D <= 255) then begin
Write1byte( GFfile, SKIPONE );
Write1byte( GFfile, D );
end else if (D <= 65535) then begin
Write1byte( GFfile, SKIPTWO );
Write2bytes( GFfile, D );
end else if (D <= 16777215) then begin
Write1byte( GFfile, SKIPTHR );
Write3bytes( GFfile, D );
end else begin
write(tty,'ERROR: huge skip, GFfile is invalid.');
end;
end;
procedure PutGFpaint
{----------------------------------------------------------------}
( var GFfile, PXLfile: fontfile;
Ch: charrec );
{-----------------------------------------------------------------
Paints the raster beginning with PXLfile↑ and
described by Ch. Uses coordinates 1..Ch.Pixelwidth and
Ch.Pixelheight..1 .
-----------------------------------------------------------------}
var Y, PXLy, PaintLength: integer;
begin
PXLbuflimit := Ceiling( Ch.pixelwidth, 8 ) - 1;
PXLbufend := PXLbuflimit - (PXLbuflimit mod 4) + 3;
if PXLbufend > pxlbufsize
then writeln(tty,'ERROR: pxlbufsize too small');
Y := Ch.Pixelheight;
for PXLy := Ch.pixelheight downto 1 do begin
ReadPXLbuf;
if Getpaint(PaintLength) then
begin
if Y=PXLy then Paint(PaintLength)
else if PaintLength > MaxNewrow
then begin
Down(Y-PXLy);
Paint(PaintLength);
end
else begin
Down(Y-PXLy-1);
Write1byte(GFfile, NEWROW0+PaintLength);
end;
Y := PXLy;
while Getpaint(PaintLength) do Paint(PaintLength);
end;
end;
Write1byte( GFfile, EOC );
end;
procedure PutGFpost
{----------------------------------------------------------------}
( var GFfile: fontfile;
var Sum, Mag, Dsize,
Postminm, Postmaxm,
Postminn, Postmaxn: integer );
{-----------------------------------------------------------------
Just the POST command w/ paramaters.
-----------------------------------------------------------------}
var PPP: integer; {pixels per point, scaled by TWO16}
begin
Write1byte( GFfile, POST ); {POST: }
Write4bytes( GFfile, GFBYTES - 1); { p[4] }
Write4bytes( GFfile, Dsize ); { ds[4] }
Write4bytes( GFfile, Sum ); { cs[4] }
PPP := round( ((Mag/5)/PPI)*TWO16 );
Write4bytes( GFfile, PPP ); { hppp[4] }
Write4bytes( GFfile, PPP ); { vppp[4] }
Write4bytes( GFfile, Postminm );
Write4bytes( GFfile, Postmaxm );
Write4bytes( GFfile, Postminn );
Write4bytes( GFfile, Postmaxn );
end;
procedure PutGFlocator
{----------------------------------------------------------------}
( var GFfile: fontfile;
Ch: charrec;
Dsize, Mag: integer );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var dm: integer;
begin
with Ch do begin
dm := round( (tfmwidth/FIX) * (Dsize/FIX) * (Mag/5) / PPI );
if (0 <= dm) and (dm < 256)
then begin
Write1byte( GFfile, CHARLOC0 );
Write1byte( GFfile, code );
Write1bytes( GFfile, dm );
Write4bytes( GFfile, tfmwidth );
Write4bytes( GFfile, GFbocptr );
end
else begin
Write1byte( GFfile, CHARLOC );
Write1byte( GFfile, code );
Write4bytes( GFfile, TWO16*dm );
Write4bytes( GFfile, 0 );
Write4bytes( GFfile, tfmwidth );
Write4bytes( GFfile, GFbocptr );
end;
end;
end;
procedure PutGFppost
{----------------------------------------------------------------}
( var GFfile: fontfile;
Postptr: integer );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var I,J: integer;
begin
Write1byte( GFfile, POSTPOST );
Write4bytes( GFfile, Postptr );
Write1byte( GFfile, GFID );
Write1byte( GFfile, SIG );
Write1byte( GFfile, SIG );
Write1byte( GFfile, SIG );
Write1byte( GFfile, SIG );
I := GFBYTES mod 4;
if I <> 0 then begin
for J := 1 to (4 - I) do Write1byte( GFfile, SIG );
end;
end;
{ main } begin
writeln(tty,HEADERSTRING);
Init( GFcomment,Postminm,Postmaxm,Postminn,Postmaxn );
LocPXLdirectory( PXLfile, FileOK );
if not FileOK then begin
writeln(tty,'ABORT: bad PXL file.');
end else begin
GetPXLendinfo( PXLfile, Font, Sum, Mag, Dsize );
Sortfont( Font );
LocPXLrasters( PXLfile );
PutGFpreamble( GFfile, GFcomment );
specials := 0;
for I := 0 to ASCIIMAX do if Charexists(Font[I]) then begin
write(tty,'[',Font[I].code:0);
PutGFboc( GFfile, Font[I], Postminm, Postmaxm, Postminn, Postmaxn );
PutGFpaint( GFfile, PXLfile, Font[I] );
write(tty,']');
end;
Postptr := GFBYTES;
PutGFpost( GFfile, Sum, Mag, Dsize,
Postminm, Postmaxm, Postminn, Postmaxn );
for I := 0 to ASCIIMAX do if Charexists(Font[I]) then begin
PutGFlocator( GFfile, Font[I], Dsize, Mag );
end;
PutGFppost( GFfile, Postptr );
end;
end.